使用Access資料庫可以便於分析資料，因此有許多人會將實驗設備產生的純文字報表檔轉入資料庫內分析，在轉這些檔案之前，總要先產生清單，然後再逐一處理，這部份我也製作了一個程式進行，以便於批次處理相關檔案。除此之外，也可應用於管理檔案，可以便於比對檔名，篩選過大檔案等功能。

程式中會運用到Terry Kreft撰寫的BrowseFolder子程式，以便於選擇資料夾，我們這裡先列出：

建議可建立另一模組儲存以下程式碼，以便於區隔開，以下程式主要是宣告一些變數與呼叫系統檔「shell32.dll」中的「SHGetPathFromIDList」功能

'http://access.mvps.org/access/api/api0002.htm
'
'************** Code Start **************
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code courtesy of
'Terry Kreft

Private Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
            "SHGetPathFromIDListA" (ByVal pidl As Long, _
            ByVal pszPath As String) As Long
            
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
            "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
            As Long
            
Private Const BIF_RETURNONLYFSDIRS = &H1

此為瀏覽資料夾的主程式：

Public Function BrowseFolder(szDialogTitle As String) As String
  Dim X As Long, bi As BROWSEINFO, dwIList As Long
  Dim szPath As String, wPos As Integer
  
    With bi
        .hOwner = hWndAccessApp
        .lpszTitle = szDialogTitle
        .ulFlags = BIF_RETURNONLYFSDIRS
        .pidlRoot = 0
    End With
    
    dwIList = SHBrowseForFolder(bi)
    szPath = Space$(512)
    X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
    
    If X Then
        wPos = InStr(szPath, Chr(0))
        BrowseFolder = Left$(szPath, wPos - 1)
    Else
        BrowseFolder = vbNullString
    End If
End Function
'*********** Code End *****************

下面這兩個程式，用於裁剪字串：

Function CutLeft(strData As String, strCut As String) As String
    '依照strCut的字元數，刪除strData左邊的字元
    CutLeft = Mid(strData, Len(strCut) + 1, Len(strData) - Len(strCut))
End Function

Function CutRight(strData As String, strCut As String) As String
    '依照strCut的字元數，刪除strData右邊的字元
    CutRight = Mid(strData, 1, Len(strData) - Len(strCut))
End Function

接下來，我們列出產生檔案清單的相關程式，主程式的部份也是參考網路上的資源再加以修改，各位也可以依照自己的需求調整程式：

'建立檔案清單
Sub PutPathFile()
    '參考來源
    'http://stackoverflow.com/questions/14245712/cycle-through-sub-folders-and-files-in-a-user-specified-root-directory

    Dim fso As Object 'FileSystemObject
    Dim fldStart As Object 'Folder
    Dim fld As Object 'Folder
    Dim fl As Object 'File
    Dim Mask As String
    Dim WorkTime, LastImpTime, StartImpTime
    Dim strTable As String
    
    '資料表名稱
    strTable = "ImpData"
    
    '如果資料表不存在,則建立一組
    If ifObjectExists(strTable) = False Then

        DoCmd.RunSQL "CREATE TABLE " & strTable & " " & _
                     "(" & _
                     " [FullPath] MEMO, " & _
                     " [Base] Text(255), " & _
                     " [Path] MEMO, " & _
                     " [File] Text(255), " & _
                     " [Ext]  Text(255), " & _
                     " [DateCreated] DATETIME, " & _
                     " [DateLastAccessed] DATETIME, " & _
                     " [DateLastModified] DATETIME, " & _
                     " [Size] DOUBLE, " & _
                     " [Attributes] SHORT " & _
                     ")"
    End If
    
    Dim objActSht As Object
    
    Set fso = CreateObject("scripting.FileSystemObject")
    
    '開啟BrowseFolder API來選擇資料夾
    strFolder = BrowseFolder("請選擇資料夾")
    
    strFolder = InputBox("請確認資料夾路徑：", , strFolder)
    
    '如果沒有選擇的話則離開程式
    If Len(strFolder) = 0 Then Exit Sub
    
    '清空原始資料
    If MsgBox("是否清空舊清單?", vbOKCancel) = vbOK Then
        RunSQL "DELETE FROM " & strTable
    End If
    
    '開始時間
    StartImpTime = Now
    
    Set fldStart = fso.GetFolder(strFolder)
    
        
    'On Error Resume Next
    
    Mask = "*.*"
    Debug.Print fldStart.path & "\"
    
    Call ListFiles(fso, fldStart, Mask, strTable)
    
    For Each fld In fldStart.SubFolders
        Call ListFiles(fso, fld, Mask, strTable)
        Call ListFolders(fso, fld, Mask, strTable)
    Next
    
    '結束時間
    LastImpTime = Now
    
    '儲存最後匯入時間
    Call ConfigSave("LastImpTime", Format(LastImpTime))
    
    WorkTime = LastImpTime - StartImpTime
    MsgBox "處理時間:" & Format(WorkTime, "HH:MM:SS")
    
End Sub

列出資料夾列表，然後再Call列出檔案列表與列出資料夾列表，如此循環下去達到遍歷所有資料的功能

Sub ListFolders(fso As Object, fldStart As Object, Mask As String, strTable As String)
    Dim fld As Object 'Folder
    For Each fld In fldStart.SubFolders
        Call ListFiles(fso, fld, Mask, strTable)
        Call ListFolders(fso, fld, Mask, strTable)
    Next

End Sub

列出檔案列表，然後將檔案的相關屬性寫入資料庫

Sub ListFiles(fso As Object, fld As Object, Mask As String, strTable As String)
    Dim fl As Object 'File
    Dim m As Object
    Dim strFile As String
    Dim strExt As String
    Dim strBase As String
    Dim strPath As String
    
    Set m = CurrentDb.OpenRecordset("SELECT * FROM " & strTable & "")
    
    For Each fl In fld.Files
        
        '把XP建立的"Thumbs.db"檔案略過
        If fl.Name Like Mask And fl.Name <> "Thumbs.db" Then

            m.AddNew
            m("FullPath") = fl.path
            strBase = fl.drive.path
            strPath = fl.parentfolder.path
            
            '如果有資料夾，則將路徑的部份去除strBase
            If Len(strPath) > Len(strBase) + 1 Then '加斜線的字元
                strPath = CutLeft(strPath, strBase)
            End If
            
            m("Base") = strBase
            m("Path") = strPath
            
            strFile = fl.Name
            strExt = fso.GetExtensionName(fl.Name)
            
            '如果有副檔名strExt，則將檔案全名的部份去除副檔名
            If Len(strExt) > 0 Then
                strFile = CutRight(strFile, "." & strExt)
            End If
            
            m("File") = strFile
            m("Ext") = strExt
            
            m("Attributes") = fl.Attributes
            m("DateCreated") = fl.DateCreated
            m("DateLastAccessed") = fl.DateLastAccessed
            m("DateLastModified") = fl.DateLastModified
            m("Size") = fl.Size
            m.Update
        End If
    Next
    Set m = Nothing

End Sub

準備好用，只要執行「PutPathFile()」子程式，即可開啟「瀏覽資料夾」視窗

選擇後，會帶出另一視窗確認路徑，如果要填入其他路徑，例如網域上的其他電腦分享資料夾亦可填上

接下來會詢問是否清除清單，如果按取消，則會保留清單，然後再加上新資料

最後會列出匯入的處理時間

清單建立完成後，可開啟「ImpData」資料表來查閱轉入的資料

以上的分享，希望對各位有幫助。